open Fr
open Midi
open PortMidi

let _ =
	initialize ();
	at_exit terminate

type delta = int
type input = device_id
type output = device_id

type info = {
	name: string;
}

let default_input = lift (get_default_input_device_id ())
let default_output = lift (get_default_output_device_id ())

let inputs = lift begin
	let l = ref [] in
	for i = 0 to count_devices () - 1 do
		if (get_device_info i).input then l := i :: !l
	done;
	List.rev (!l)
end

let outputs = lift begin
	let l = ref [] in
	for i = 0 to count_devices () - 1 do
		if (get_device_info i).output then l := i :: !l
	done;
	List.rev (!l)
end

let input_info d = { name = (get_device_info d).PortMidi.name }
let output_info d = { name = (get_device_info d).PortMidi.name }


let _inputs = ref []

(* TODO: error checking *)

let clock =
	let c, b = new_cell 0 in
	PortTime.start 1 (fun t ->
		(* first or last... does it matter? *)
		set_cell c t;
		List.iter (fun (i, r, d) ->
			let events = ref [] in
			while poll i do
				List.iter (fun event ->
					try String.iter (fun c ->
						match decode d (int_of_char c) with
						| Some m ->
							(* ideally we should take timestamp of first
							 * sysex packet *)
							events := (event.timestamp - t, m) :: !events;
							raise Exit
						| None -> ()) event.message
					with Exit -> ()
					) (read i 16)
			done;
			send_event r !events
			) !_inputs);
	b

let _input d =
	event_source
		(fun r ->
			(* buffer size dependent on resolution *)
			let i = open_input_simple d 16 in
			set_filter i 0;
			let c = i, r, create_decoder () in
			_inputs := c :: !_inputs;
			c)
		(fun (i, r, d as c) ->
			_inputs := List.filter (fun c' -> c' != c) !_inputs;
			close i)

let input d = collapse_e (lift1 _input d)

type _handle = { stream: stream; endpoint: endpoint }

let _connect_output ?(latency=10) d s =
	(* buffer size dependent on resolution and latency *)
	let o = open_output_simple d 128 latency
	and e = create_encoder ()
	and b = Buffer.create 4 in
	{ stream = o;
	  endpoint = register_e (on s l ->
	  	let l = List.fast_sort
	  		(fun ((da: delta), _) ((db: delta), _) -> compare da db) l
		and t = PortTime.time () in
	  	let data = List.fold_left (fun l (d, m) ->
	  		let ts = t + d in
	  		let l = List.fold_left
	  			(fun l d ->
	  				Buffer.add_char b (char_of_int d);
	  				if Buffer.length b >= 4 then
	  					let s = Buffer.contents b in
	  					Buffer.clear b;
	  					{ message = s; timestamp = ts } :: l
					else l)
	  			l (encode e m) in
			if Buffer.length b > 0 then
				let s = Buffer.contents b in
				Buffer.clear b;
				{ message = s; timestamp = ts } :: l
			else l
			) [] l in
		write o (List.rev data)
		) }

let _disconnect_output h =
	unregister h.endpoint;
	close h.stream

(*let connect_output ?latency d s =
	register_b begin
		collect_b (fun h d ->
				_disconnect_output h;
				_connect_output ?latency d s)
			(value_now d) (changes d)
	end

let disconnect_output h =
	unregister_b h;
	_disconnect_output (value_now h)*)

type handle = { handle: _handle option ref; endpoint: endpoint }

let connect_output ?latency d s =
	let h = ref None in
	{ handle = h;
	  endpoint =
	  	register_e (on (merge_e [changes d; snapshot_b d now]) d ->
			(match !h with Some h -> _disconnect_output h | None -> ());
			h := Some (_connect_output ?latency d s)) }

let disconnect_output h =
	unregister h.endpoint;
	(match !(h.handle) with Some h -> _disconnect_output h | None -> ())

let list_rev_concat l =
	List.fold_left (List.fold_left (fun l a -> a :: l)) [] l
let list_rev_concat_map f l =
	List.fold_left (fun l a -> List.fold_left (fun l a -> a :: l) l (f a)) [] l
	
let merge_m e = map_e list_rev_concat (par_e e)
let map_m f e = map_e (List.rev_map (fun (d, m) -> d, f m)) e
let concat_map_m f e =
	map_e (List.fold_left (fun l (d, m) ->
		List.fold_left (fun l m -> (d, m) :: l) l (f m)) []) e
